home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
tjgold.zip
/
INSTALL.001
/
DFBTREUT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-07-19
|
47KB
|
1,222 lines
{--------------------------------------------------------------------------}
{ Product: TechnoJock's Turbo Toolkit }
{ Version: GOLD }
{ Build: 1.01 }
{ }
{ The index routines used in TTT Gold were developed by Dean Farwell II }
{ and are an adaptation of his excellent TBTREE database tools. }
{ }
{ Copyright 1988-1994 Dean Farwell II }
{ Portions Copyright 1986-1995 TechnoJock Software, Inc. }
{ All Rights Reserved }
{ Restricted by License }
{--------------------------------------------------------------------------}
{********************************}
{ Unit: DFBTREUT }
{********************************}
unit DFBTreUt;
{$I-}
(*****************************************************************************)
(* *)
(* N U M B E R D E C L A R A T I O N S *)
(* *)
(*****************************************************************************)
(* This unit has declarations for often used standard constants and types.
These are obviously not all inclusive and can be added to as desired. It
also contains on routine. *)
(*////////////////////////// I N T E R F A C E //////////////////////////////*)
interface
const
MAXBYTE = 255;
MAXSHORTINT = 127;
MAXWORD = 65535;
(* the following constants are used to reflect the number of bytes
required to hold the corresponding variable types. *)
BYTESIZE = 1;
SHORTINTSIZE = 1;
INTEGERSIZE = 2;
LONGINTSIZE = 4;
WORDSIZE = 2;
REALSIZE = 6;
SINGLESIZE = 4;
DOUBLESIZE = 8;
EXTENDEDSIZE = 10;
COMPSIZE = 8;
type
PosByte = 1 .. MAXBYTE;
PosShortInt = 1 .. MAXSHORTINT;
PosInteger = 1 .. MAXINT;
PosLongInt = 1 .. MAXLONGINT;
PosWord = 1 .. MAXWORD;
Condition = (EX, (* Exists *)
LT, (* Less Than *)
LE, (* Less Than Or Equal To *)
EQ, (* Equal To *)
NE, (* Not Equal To *)
GE, (* Greater Than Or Equal To *)
GT); (* Greater Than *)
StringCondition = (ST, (* String Starts With Substring *)
CO, (* String Contains Substring *)
EN); (* String Ends With Substring *)
ValueType = (INVALIDVALUE,
BYTEVALUE,
SHORTINTVALUE,
INTEGERVALUE,
LONGINTVALUE,
WORDVALUE,
STRINGVALUE,
REALVALUE,
SINGLEVALUE,
DOUBLEVALUE,
EXTENDEDVALUE,
COMPVALUE,
BYTEARRAYVALUE);
SizeType = 1 .. MAXBYTE + 1;
type
FnString = String[79]; (* See FNSIZE definition above for an
example of a file name *)
(* Record number types *)
const
RNSIZE = 4;
type
RecordNumber = 0 .. MAXLONGINT; (* range of record numbers *)
PrNumber = RecordNumber; (* Physical Record Number within a file *)
LrNumber = RecordNumber; (* Logical Record Number within file *)
const
PAGESIZE = 512; (* Number of bytes in a Physical Record *)
type
PageRange = 1 .. PAGESIZE; (* type used primarily for indexing a page
byte by byte. *)
SinglePage = Array [PageRange] of Byte; (* type used to hold one page *)
(* This routine will return the size needed to store a variable of the
given type. This is true for all types except for STRINGVALUE and
BYTEARRAYVALUE. For these two types, the size can vary from 1 to 256
so 1 is returned. *)
function GetSizeFromVType(vType : ValueType) : SizeType;
type
HexArray = String[2];
(* Finds the hex character for a given 4 bit value
for example - GetHexChar(11) = 'B' *)
function GetHexChar(var x : Byte) : Char;
(* This function returns the hex value for an associated 8 bit byte. The value
is returned as a string of type HexArray (2 bytes)
for example - ByteToHex(255) = 'FF' *)
function ByteToHex(x : Byte) : HexArray;
type
TimeArr = record
lsLongInt : LongInt; (* least significant long integer *)
msLongInt : LongInt; (* most significant long integer *)
end;
type
Comparison = (LESSTHAN,EQUALTO,GREATERTHAN);
(* This routine will compare two values and return the result of the comparison.
The result is of type Comparison and LESSTHAN, EQUALTO, or GREATERTHAN will
be returned. The values compared must be of the same type. Legal types are
those enumerated in the type ValueType. The type of the values is passed in
as a parameter along with the values.
note : the values must reside in a variable since a var parameter is used.
This is necessary since the address is needed to facilitate the use of this
routine with multiple types. *)
function CompareValues(var paramValue1;
var paramValue2;
vType : ValueType) : Comparison;
(* This routine will convert the given value to a string. This can be used to
facilitate the printing of a value. *)
function ConvertValueToString(var paramValue1;
vType : ValueType) : String;
(* This routine does two things that are important to understand when
using it. It first increments the internal clock. It then sets x to this
new "time". *)
procedure GetTime(var x : TimeArr);
(* This function compares two time arrays. LESSTHAN is returned if X is less
than Y (earlier). GREATERTHAN is returned if X is greater than Y (later).
If they are equal then EQUALTO is returned *)
function CompareTime(var x : TimeArr;
var y : TimeArr) : Comparison;
(* This routine sets both long integer fields of a timeArr variable to the
maximum possible value (MAXLONGINT) *)
procedure SetMaxTime(var x : TimeArr);
(* the following type supports the byte handling routine(s) *)
type
BytePosition = 0 .. 7;
BitValue = 0 .. 1;
(* This function will determine if a certain bit within a target byte is
toggled on (equal to 1). The bit position is is the position within the
byte of the bit to be tested. The least significant bit is 0 then most
significant bit is 7. If the bit is 1 TRUE will be returned. If the bit
is 0 FALSE will be returned. Notice that the target byte can be of any
type. in this way, the routine will handle any a bit byte. In other
words a character could also be passed in. *)
(* Boolean functions return zero flag set and AL=0 for false,
zero flag reset and AL=1 for true *)
function BitOn(var targetByte;
bitNum : BytePosition ):boolean;
(* pop cx ;bitNum
pop bx ;offset of targetByte
pop es ;segment of targetByte
mov al, byte ptr es:[bx] ;get the byte
shr al,cl ;get desired bit
;in rightmost position
and al,01 ;check for bit set *)
INLINE($59/$5B/$07/$26/$8A/$07/$D2/$E8/$24/$01);
(* This will set a given bit to a value of zero or one depending on what is
passed in as the last parameter. See above for description of the other
parameters *)
procedure SetBit(var targetByte;
bitNum : BytePosition;
bit : BitValue );
(* pop ax ;bit
pop cx ;bitNum
pop bx ;offset of targetByte
pop es ;segment of targetByte
mov ah,11111110b ;mask to reset
rol ah,cl ;get it in place
and byte ptr es:[bx],ah ;reset regardless
shl al,cl ;mask to set/reset
or byte ptr es:[bx],al ;make bit proper value *)
INLINE($58/$59/$5B/$07/$B4/$FE/$D2/$C4/$26/$20/$27/$D2/$E0/$26/$08/$07);
type
ByteArrayRange = 0 .. MAXBYTE;
ByteArray = Array [ByteArrayRange] of Byte; (* This handy type is used
to store a from 1 to
255 bytes. It is much
a string in that the
first element is the
number of bytes in the
array. All bytes after
the significant number
of bytes are not
significant. This is
used for concatenated
indexes *)
type
PrintTextDevice = Text;
PrinterType = (GENERIC,EPSON,HP);
LinesPerInch = 1 .. 48;
procedure SetPrinterType(p : PrinterType);
procedure FormFeed(var lst : PrintTextDevice);
procedure InitializePrinter(var lst : PrintTextDevice);
procedure SetCompressedMode(var lst : PrintTextDevice);
procedure CancelCompressedMode(var lst : PrintTextDevice);
procedure SetEmphasizedMode(var lst : PrintTextDevice);
procedure CancelEmphasizedMode(var lst : PrintTextDevice);
(* This works for HP printers only. It will set the number of lines per inch
to the specified legal value. The legal values are 1,2,3,4,6,12,24,48.
Other values will be ignored. *)
procedure SetLinesPerInch(var lst : PrintTextDevice;
n : LinesPerInch);
const
MAXSTRINGLENGTH = 255; (* max characters in a string *)
type
StringLengthRange = 0 .. MAXSTRINGLENGTH; (* range of number of
characters in a string *)
(* Takes a string and adds up the integer value of each individual byte.
This total can be used to randomize the string for Hashing, etc. *)
function TotalString(var str : String) : Word;
(* This routine will move records for the given file down n records. This
will free up n physical records for use. The first record to be moved is
passed in firstRec and the last record to move is lastRec. lastRec must be
the last physical record in the file. firstRec and lastRec will be
returned with values updated to reflect where the records now reside. The
new last record will be written to disk (forced) to ensure that all
physical records (from the beginning to the end of the file) will exist on
the disk. *)
procedure MoveRecords(fName : FnString;
var fId : File; (* var for speed only *)
var firstRec : PrNumber;
var lastRec : PrNumber;
n : PrNumber);
procedure FetchFileParameters(var dFName : FnString; (* var for speed only *)
var fId : File; (* var for speed only *)
var pRec;
size : PageRange);
(* This procedure will copy the contents of pRec and save it to the zeroth
physical record in the data file. *)
procedure SaveFileParameters(var dFName : FnString; (* var for speed only *)
var fId : File; (* var for speed only *)
var pRec;
size : PageRange);
(* This routine will perform two important functions. First, it will set the
bit corresponding to rNum to show that the record is used. Second, it will
find the next available record number and will return that record number.
It may require the addition of one bitmap record to do that. If this is
required, it will be performed automatically. *)
function FindNextAvailInBitmap(fName : FnString;
var fId : File; (* var for speed only *)
firstBMRec : PrNumber;
var lastBMRec : PrNumber;
rNum : RecordNumber) : RecordNumber;
(* This routine will set the bit associated with rNum in the file fName to
the desired value. It will calculate the correct bitmap record and read it
in, set the bit to the value specified by bit (the parameter of type
BitValue passed in) and store the bitmap record. *)
procedure SetBitInBitmap(fName : FnString;
var fId : File; (* var for speed only *)
firstBMRec : PrNumber;
rNum : RecordNumber;
bit : BitValue);
(* This routine will check to see if the bit associated with rNum in the file
fName is set or not. The routine will return TRUE if the bit is set. *)
function CheckBitInBitmap(fName : FnString;
var fId : File; (* var for speed only *)
firstBMRec : PrNumber;
rNum : RecordNumber) : Boolean;
const
NOERROR = 0;
type
IOErrorCode = Integer;
var
bTreeErrorCode : IOErrorCode;
procedure SetBTreeError(errorCode : IOErrorCode);
function GetBTreeError : IOErrorCode;
function BTreeErrorOccurred : Boolean;
(*///////////////////// I M P L E M E N T A T I O N /////////////////////////*)
implementation
uses
Dos,
DFPage;
(* This routine will return the size needed to store a variable of the
given type. This is true for all types except for STRINGVALUE and
BYTEARRAYVALUE. For these two types, the size can vary from 1 to 256
so 1 is returned. *)
function GetSizeFromVType(vType : Valuetype) : SizeType;
begin
case vType of
BYTEVALUE : GetSizeFromVType := BYTESIZE;
SHORTINTVALUE : GetSizeFromVType := SHORTINTSIZE;
INTEGERVALUE : GetSizeFromVType := INTEGERSIZE;
LONGINTVALUE : GetSizeFromVType := LONGINTSIZE;
WORDVALUE : GetSizeFromVType := WORDSIZE;
STRINGVALUE : GetSizeFromVType := 1;
REALVALUE : GetSizeFromVType := REALSIZE;
SINGLEVALUE : GetSizeFromVType := SINGLESIZE;
DOUBLEVALUE : GetSizeFromVType := DOUBLESIZE;
EXTENDEDVALUE : GetSizeFromVType := EXTENDEDSIZE;
COMPVALUE : GetSizeFromVType := COMPSIZE;
BYTEARRAYVALUE : GetSizeFromVType := 1;
end; (* end of case statement *)
end; (* end of GetVSizeFromVType *)
(* Finds the hex character for a given 4 bit value
for example - GetHexChar(11) = 'B' *)
function GetHexChar(var x : Byte) : Char;
var
result1 : Byte;
result2 : Char absolute result1;
begin
if (x >= 0) and (x <=9) then
result1 := x + 48
else
result1 := x + 55;
GetHexChar := result2;
end; (* End of GetHexChar Routine *)
(* This function returns the hex value for an associated 8 bit byte. The value
is returned as a string of type HexArray (2 bytes)
for example - ByteToHex(255) = 'FF' *)
Function ByteToHex(x : Byte) : HexArray;
var
low,
high : Byte;
begin
high := x div 16;
low := x mod 16;
ByteToHex := GetHexChar(high) + GetHexChar(low);
end; (* End of ByteToHex Routine *)
var
clock : TimeArr;
(* This routine does two things that are important to understand when
using it. It first increments the internal clock. It then sets x to this
new "time". *)
procedure GetTime(var x : TimeArr);
begin
if clock.lsLongInt = MAXLONGINT then
begin
clock.lsLongInt := 0;
Inc(clock.msLongInt);
end
else
begin
Inc(clock.lsLongInt);
end;
x := clock;
end; (* end of GetTime routine *)
(* This function compares two time arrays. LESSTHAN is returned if X is less
than Y (earlier). GREATERTHAN is returned if X is greater than Y (later).
If they are equal then EQUALTO is returned *)
function CompareTime(var x : TimeArr;
var y : TimeArr) : Comparison;
begin
if x.msLongInt = y.msLongInt then
begin
if x.lsLongInt < y.lsLongInt then
begin
CompareTime := LESSTHAN;
Exit;
end
else
begin
if x.lsLongInt = y.lsLongInt then
begin
CompareTime := EQUALTO;
Exit
end
else
begin
CompareTime := GREATERTHAN;
Exit;
end;
end;
end
else
begin
if x.msLongInt < y.msLongInt then
begin
CompareTime := LESSTHAN;
Exit;
end
else
begin
if x.msLongInt = y.msLongInt then
begin
CompareTime := EQUALTO;
Exit;
end
else
begin
CompareTime := GREATERTHAN;
Exit;
end;
end;
end;
end; (* end of CompareTime routine *)
(* This routine will print the two long integers that make up x (of type
TimeArr) *)
procedure PrintTime(x : TimeArr);
begin
Writeln('Most Significant Long Integer = ',x.msLongInt);
Writeln('Least Significant Long Integer = ',x.lsLongInt);
end; (* end of PrintTime routine *)
(* This routine sets both long integer fields of a timeArr variable to the
maximum possible value (MAXLONGINT) *)
procedure SetMaxTime(var x : TimeArr);
begin
x.lsLongInt := MAXLONGINT;
x.msLongInt := MAXLONGINT;
end; (* end of SetMaxTime routine *)
(* This routine will compare two values and return the result of the comparison.
The result is of type Comparison and LESSTHAN, EQUALTO, or GREATERTHAN will
be returned. The values compared must be of the same type. Legal types are
those enumerated in the type ValueType. The type of the values is passed in
as a parameter along with the values.
note : the values must reside in a variable since a var parameter is used.
This is necessary since the address is needed to facilitate the use of this
routine with multiple types. *)
function CompareValues(var paramValue1;
var paramValue2;
vType : ValueType) : Comparison;
var
byteValue1 : Byte absolute paramValue1;
byteValue2 : Byte absolute paramValue2;
shortIntValue1 : ShortInt absolute paramValue1;
shortIntValue2 : ShortInt absolute paramValue2;
integerValue1 : Integer absolute paramValue1;
integerValue2 : Integer absolute paramValue2;
longIntValue1 : LongInt absolute paramValue1;
longIntValue2 : LongInt absolute paramValue2;
wordValue1 : Word absolute paramValue1;
wordValue2 : Word absolute paramValue2;
stringValue1 : String absolute paramValue1;
stringValue2 : String absolute paramValue2;
realValue1 : Real absolute paramValue1;
realValue2 : Real absolute paramValue2;
singleValue1 : Single absolute paramValue1;
singleValue2 : Single absolute paramValue2;
doubleValue1 : Double absolute paramValue1;
doubleValue2 : Double absolute paramValue2;
extendedValue1 : Extended absolute paramValue1;
extendedValue2 : Extended absolute paramValue2;
compValue1 : Comp absolute paramValue1;
compValue2 : Comp absolute paramValue2;
byteArrayValue1 : ByteArray absolute paramValue1;
byteArrayValue2 : ByteArray absolute paramValue2;
cnt : ByteArrayRange;
begin
case vType of
BYTEVALUE :
begin
if byteValue1 < byteValue2 then CompareValues := LESSTHAN
else if byteValue1 = byteValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
SHORTINTVALUE :
begin
if shortIntValue1 < shortIntValue2 then CompareValues := LESSTHAN
else if shortIntValue1 = shortIntValue2 then CompareValues :=EQUALTO
else CompareValues := GREATERTHAN;
end;
INTEGERVALUE :
begin
if integerValue1 < integerValue2 then CompareValues := LESSTHAN
else if integerValue1 = integerValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
LONGINTVALUE :
begin
if longIntValue1 < longIntValue2 then CompareValues := LESSTHAN
else if longIntValue1 = longIntValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
WORDVALUE :
begin
if wordValue1 < wordValue2 then CompareValues := LESSTHAN
else if wordValue1 = wordValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
STRINGVALUE:
begin
if stringValue1 < stringValue2 then CompareValues := LESSTHAN
else if stringValue1 = stringValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
REALVALUE :
begin
if realValue1 < realValue2 then CompareValues := LESSTHAN
else if realValue1 = realValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
(* The following types are only for 8087 - and are compiled only if the unit
is compiled using {$N+} *)
{$IFOPT N+}
SINGLEVALUE :
begin
if singleValue1 < singleValue2 then CompareValues := LESSTHAN
else if singleValue1 = singleValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
DOUBLEVALUE :
begin
if doubleValue1 < doubleValue2 then CompareValues := LESSTHAN
else if doubleValue1 = doubleValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
EXTENDEDVALUE :
begin
if extendedValue1 < extendedValue2 then CompareValues := LESSTHAN
else if extendedValue1 = extendedValue2 then CompareValues :=EQUALTO
else CompareValues := GREATERTHAN;
end;
COMPVALUE :
begin
if compValue1 < compValue2 then CompareValues := LESSTHAN
else if compValue1 = compValue2 then CompareValues := EQUALTO
else CompareValues := GREATERTHAN;
end;
{$ENDIF}
(* the following type was added in version 1.4 *)
BYTEARRAYVALUE :
begin
cnt := 1;
while TRUE do
begin
if byteArrayValue1[0] < cnt then
begin
if byteArrayValue2[0] < cnt then
begin
CompareValues := EQUALTO;
end
else
begin
CompareValues := LESSTHAN;
end;
Exit;
end;
if byteArrayValue2[0] < cnt then
begin
CompareValues := GREATERTHAN;
Exit;
end;
if byteArrayValue1[cnt] < byteArrayValue2[cnt] then
begin
CompareValues := LESSTHAN;
Exit;
end;
if byteArrayValue1[cnt] > byteArrayvalue2[cnt] then
begin
CompareValues := GREATERTHAN;
Exit;
end;
if cnt = MAXBYTE then
begin
CompareValues := EQUALTO;
Exit;
end;
Inc(cnt);
end;
end;
end; (* end of case statement *)
end; (* end of CompareValues routine *)
(* This routine will convert the given value to a string. This can be used to
facilitate the printing of a value. *)
function ConvertValueToString(var paramValue1;
vType : ValueType) : String;
var
byteValue1 : Byte absolute paramValue1;
shortIntValue1 : ShortInt absolute paramValue1;
integerValue1 : Integer absolute paramValue1;
longIntValue1 : LongInt absolute paramValue1;
wordValue1 : Word absolute paramValue1;
stringValue1 : String absolute paramValue1;
realValue1 : Real absolute paramValue1;
singleValue1 : Single absolute paramValue1;
doubleValue1 : Double absolute paramValue1;
extendedValue1 : Extended absolute paramValue1;
compValue1 : Comp absolute paramValue1;
byteArrayValue1 : ByteArray absolute paramValue1;
s : String;
begin
case vType of
BYTEVALUE : Str(byteValue1,s);
SHORTINTVALUE : Str(shortIntValue1,s);
INTEGERVALUE : Str(integerValue1,s);
LONGINTVALUE : Str(longIntValue1,s);
WORDVALUE : Str(wordValue1,s);
STRINGVALUE : s := String(stringValue1);
REALVALUE : Str(realValue1,s);
(* The following types are only for 8087 - and are compiled only if the unit
is compiled using {$N+} *)
{$IFOPT N+}
SINGLEVALUE : Str(singleValue1,s);
DOUBLEVALUE : Str(doubleValue1,s);
EXTENDEDVALUE : Str(extendedValue1,s);
COMPVALUE : Str(compValue1,s);
{$ENDIF}
(* the following type was added in version 1.4 *)
BYTEARRAYVALUE : Move(byteArrayValue1,s,byteArrayValue1[0]);
end; (* end of case statement *)
ConvertValueToString := s;
end; (* end of ConvertValueToString routine *)
const (* The following are the printer constants *)
GENERICFORMFEED = #12;
HPINIT = #27'E'#27'(s0p12h10v0s0b3T';
HPFORMFEED = #12;
HPITALIC = #27'(s1S';
HPNOITALIC = #27'(s0S';
HPBOLD = #27'(s3B';
HPNOBOLD = #27'(s0B';
HPCOMPRESSED = #27'E'#27'(s0p16.66h8.5v0s0b0T';
HPCNXCOMPRESSED = #27'(s0p12h10v0s0b3T';
EPSONINIT = #0; (* to use replace with correct codes *)
EPSONFORMFEED = #12;
EPSONITALIC = #0; (* to use replace with correct codes *)
EPSONNOITALIC = #0; (* to use replace with correct codes *)
EPSONBOLD = #0; (* to use replace with correct codes *)
EPSONNOBOLD = #0; (* to use replace with correct codes *)
EPSONCOMPRESSED = #0; (* to use replace with correct codes *)
EPSONCNXCOMPRESSED = #0; (* to use replace with correct codes *)
type
PrinterCodes = (PRINITIALIZE,
PRFORMFEED,
PRITALIC,PRNOITALIC,
PRBOLD,PRNOBOLD,
PRULINE,PRNOULINE,
PRCOMPRESSED,PRCNXCOMPRESSED);
PrinterCodeString = String;
PrinterCodeArray = array [PrinterCodes] of PrinterCodeString;
var
pCodeArray : PrinterCodeArray;
prType : PrinterType;
procedure SetPrinterType(p : PrinterType);
begin
case p of
GENERIC:
begin
pCodeArray[PRFORMFEED] := GENERICFORMFEED;
end;
HP:
begin
pCodeArray[PRINITIALIZE] := HPINIT;
pCodeArray[PRFORMFEED] := HPFORMFEED;
pCodeArray[PRITALIC] := HPITALIC;
pCodeArray[PRNOITALIC] := HPNOITALIC;
pCodeArray[PRBOLD] := HPBOLD;
pCodeArray[PRNOBOLD] := HPNOBOLD;
pCodeArray[PRBOLD] := HPBOLD;
pCodeArray[PRCOMPRESSED] := HPCOMPRESSED;
pCodeArray[PRCNXCOMPRESSED] := HPCNXCOMPRESSED;
end;
EPSON:
begin
pCodeArray[PRINITIALIZE] := EPSONINIT;
pCodeArray[PRFORMFEED] := EPSONFORMFEED;
pCodeArray[PRITALIC] := EPSONITALIC;
pCodeArray[PRNOITALIC] := EPSONNOITALIC;
pCodeArray[PRBOLD] := EPSONBOLD;
pCodeArray[PRNOBOLD] := EPSONNOBOLD;
pCodeArray[PRBOLD] := EPSONBOLD;
pCodeArray[PRCOMPRESSED] := EPSONCOMPRESSED;
pCodeArray[PRCNXCOMPRESSED] := EPSONCNXCOMPRESSED;
end;
end;
end; (* end of SetPrinterCodes routine *)
procedure FormFeed(var lst : PrintTextDevice);
begin
Write(lst,pCodeArray[PRFORMFEED]);
end;
procedure InitializePrinter(var lst : PrintTextDevice);
begin
Write(lst,pCodeArray[PRINITIALIZE]);
end;
procedure SetCompressedMode(var lst : PrintTextDevice);
begin
Write(lst,pCodeArray[PRCOMPRESSED]);
end;
procedure CancelCompressedMode(var lst : PrintTextDevice);
begin
Write(lst,pCodeArray[PRCNXCOMPRESSED]);
end;
procedure SetEmphasizedMode(var lst : PrintTextDevice);
begin
Write(lst,pCodeArray[PRBOLD]);
end;
procedure CancelEmphasizedMode(var lst : PrintTextDevice);
begin
Write(lst,pCodeArray[PRNOBOLD]);
end;
(* This works for HP printers only. It will set the number of lines per inch
to the specified legal value. The legal values are 1,2,3,4,6,12,24,48.
Other values will be ignored. *)
procedure SetLinesPerInch(var lst : PrintTextDevice;
n : LinesPerInch);
begin
case n of
1: write(lst,#27,#038,#108,#49,#68);
2: write(lst,#27,#038,#108,#50,#68);
3: write(lst,#27,#038,#108,#51,#68);
4: write(lst,#27,#038,#108,#52,#68);
6: write(lst,#27,#038,#108,#54,#68);
8: write(lst,#27,#038,#108,#56,#68);
12: write(lst,#27,#038,#108,#49,#50,#68);
16: write(lst,#27,#038,#108,#49,#54,#68);
24: write(lst,#27,#038,#108,#50,#52,#68);
48: write(lst,#27,#038,#108,#52,#56,#68);
end;
end;
(* Takes a string and adds up the integer value of each individual byte.
This total can be used to randomize the string for Hashing, etc. *)
function TotalString(var str : String ) : Word;
begin
Inline($31/$C0/ (* xor ax,ax ; zero out accumulator *)
$31/$C9/ (* xor cx,cx ; zero out counter *)
$C4/$BE/>STR/ (* les di, >str[bp] ; load pointer to str *)
$26/$8A/$0D/ (* es: mov cl,[di] ; *)
(* CountLoop: *)
$47/ (* inc di ; next char *)
$26/$02/$05/ (* es: add al,[di] ; add value of char *)
$80/$D4/$00/ (* adc ah,0 ; add carry
if required *)
$E2/$F7/ (* loop CountLoop ; get next char *)
$89/$46/$FE); (* mov [bp-02],ax ; put total on stack *)
end; (* end of TotalString routine *)
(* This routine converts a string from ASCIIZ (null delimined) to Turbo Pascal
format *)
function Asciiz2Str(var aStr) : string;
var str : String;
ctr : Word;
az: Array[1 .. MAXSTRINGLENGTH] of Char absolute aStr;
begin
ctr := 1;
{$B-} (* short circuit boolean evaluation required *)
while (ctr <= MAXSTRINGLENGTH) and (az[ctr] <> #0) do
begin
str[ctr] := az[ctr];
Inc(ctr);
end;
str[0] := Chr(ctr-1);
Asciiz2Str := str;
end; (* end of Ascii2Str routine *)
(* This routine will move records for the given file down n records. This
will free up n physical records for use. The first record to be moved is
passed in firstRec and the last record to move is lastRec. lastRec must be
the last physical record in the file. firstRec and lastRec will be
returned with values updated to reflect where the records now reside. The
new last record will be written to disk (forced) to ensure that all
physical records (from the beginning to the end of the file) will exist on
the disk. *)
procedure MoveRecords(fName : FnString;
var fId : File; (* var for speed only *)
var firstRec : PrNumber;
var lastRec : PrNumber;
n : PrNumber);
var
zeroPage,
page : SinglePage;
cnt : PrNumber;
begin
FillChar(zeroPage,PAGESIZE,0); (* zero out old page *)
for cnt := lastRec downto firstRec do
begin
FetchPage(fName,fId,cnt,page);
if BTreeErrorOccurred then Exit;
if cnt = lastRec then
begin (* this is needed to force the physical file to
be extended, thus ensuring that all physical
records from the beginning to the new end of
the file will exist *)
StorePage(fName,fId,cnt + n,page);
if BTreeErrorOccurred then Exit;
end
else
begin
StorePage(fName,fId,cnt + n,page);
if BTreeErrorOccurred then Exit;
end;
StorePage(fName,fId,cnt,zeroPage); (* store empty page in old place *)
if BTreeErrorOccurred then Exit;
end;
Inc(firstRec,n);
Inc(lastRec,n);
end; (* end of MoveRecords routine *)
(* This routine will calculate the bit location for the given record
number (rNum). firstBMRec is needed as the starting location. The
location is returned in prNum, byteNum and bitNum. The routine does not
affect the bitmaps themselves. *)
procedure CalculateBitmapBitLocation(firstBMRec : PrNumber;
rNum : RecordNumber;
var prNum : PrNumber;
var byteNum : PageRange;
var bitNum : BytePosition);
begin
prNum := ((rNum - 1) Div (8 * PAGESIZE)) + firstBMRec;
byteNum := (((rNum - 1) Mod (8 * PAGESIZE)) Div 8) + 1;
bitNum := (rNum - 1) Mod 8;
bitNum := (bitNum Xor 7) And 7; (* this will yield the correct bit
position within the byte. This is
necessary because bit 7 (most
significant) in the byte is the
existence bit for the first record
not the eighth *)
end; (* end of CalculateBitmapBitLocation routine *)
(* This procedure will read the zeroth physical record from the given file and
return the number of bytes requested in the variable pRec. *)
procedure FetchFileParameters(var dFName : FnString; (* var for speed only *)
var fId : File; (* var for speed only *)
var pRec;
size : PageRange);
var
page : SinglePage;
begin
FetchPage(dFName,fId,0,page);
if BTreeErrorOccurred then Exit;
Move(page,pRec,size);
end; (* end of FetchFileParameters procedure *)
(* This procedure will copy the contents of pRec and save it to the zeroth
physical record in the data file. *)
procedure SaveFileParameters(var dFName : FnString; (* var for speed only *)
var fId : File; (* var for speed only *)
var pRec;
size : PageRange);
var
page : SinglePage;
begin
FetchPage(dFName,fId,0,page);
if BTreeErrorOccurred then Exit;
Move(pRec,page,size);
StorePage(dFName,fId,0,page);
if BTreeErrorOccurred then Exit;
end; (* end of SaveFileParameters procedure *)
(* This routine will calculate the physical record number corresponding to the
given record number (rNum). firstBMRec is needed as the starting
location. *)
function CalculateBitmapRecord(firstBMRec : PrNumber;
rNum : RecordNumber) : PrNumber;
begin
CalculateBitmapRecord := ((rNum - 1) Div (8 * PAGESIZE)) + firstBMRec;
end; (* end of CalculateBitmapBitRecord routine *)
(* This routine will perform two important functions. First, it will set the
bit corresponding to rNum to show that the record is used. Second, it will
find the next available record number and will return that record number.
It may require the addition of one bitmap record to do that. If this is
required, it will be performed automatically. *)
function FindNextAvailInBitmap(fName : FnString;
var fId : File; (* var for speed only *)
firstBMRec : PrNumber;
var lastBMRec : PrNumber;
rNum : RecordNumber) : RecordNumber;
var
page : SinglePage; (* copy of page in buffer *)
prNum : PrNumber;
byteNum : PageRange; (* byte position within page *)
bitNum : BytePosition; (* bit position within byte *)
done : Boolean; (* byte loop *)
begin
CalculateBitmapBitLocation(firstBMRec,rNum,prNum,byteNum,bitNum);
FetchPage(fName,fId,prNum,page);
if BTreeErrorOccurred then Exit;
SetBit(page[byteNum],bitNum,1);
StorePage(fName,fId,prNum,page);
if BTreeErrorOccurred then Exit;
while TRUE do (* BITMAP record loop *)
begin
done := FALSE;
while not done do (* byte loop *)
begin
if page[byteNum] <> MAXBYTE then
(* the check against MAXBYTE is for efficiency
since it will preclude checking individual
bits for a byte in which all bits are set
to one *)
begin
bitNum := 7;
while TRUE do
begin (* bit loop *)
if not BitOn(page[byteNum],bitNum) then
begin
FindNextAvailInBitmap := ((prNum - firstBMRec) *
PAGESIZE * 8) +
((byteNum - 1) * 8) +
(8 - bitNum);
Exit; (* only way out of routine *)
end
else
begin
Dec(bitNum);
end;
end;
end;
if byteNum = PAGESIZE then
begin
done := TRUE;
end
else
begin
Inc(byteNum);
end;
end;
Inc(prNum);
byteNum := 1;
if PageExists(fName,fId,prNum) then (* if not past last record *)
begin
FetchPage(fName,fId,prNum,page); (* get next b m record *)
if BTreeErrorOccurred then Exit;
end
else
begin
FillChar(page,PAGESIZE,0); (* create new record page
for this bit map record *)
StorePage(fName,fId,prNum,page); (* store the new page *)
if BTreeErrorOccurred then Exit;
lastBMRec := prNum; (* update value of lastBMRec *)
end;
end;
end; (* end of FindNextAvailInBitmap routine *)
(* This routine will set the bit associated with rNum in the file fName to
the desired value. It will calculate the correct bitmap record and read it
in, set the bit to the value specified by bit (the parameter of type
BitValue passed in) and store the bitmap record. *)
procedure SetBitInBitmap(fName : FnString;
var fId : File; (* var for speed only *)
firstBMRec : PrNumber;
rNum : RecordNumber;
bit : BitValue);
var
page : SinglePage;
prNum : PrNumber;
byteNum : PageRange;
bitNum : BytePosition;
begin
CalculateBitmapBitLocation(firstBMRec,rNum,prNum,byteNum,bitNum);
FetchPage(fName,fId,prNum,page);
if BTreeErrorOccurred then Exit;
SetBit(page[byteNum],bitNum,bit);
StorePage(fName,fId,prNum,page);
if BTreeErrorOccurred then Exit;
end; (* end of SetBitInBitmap routine *)
(* This routine will check to see if the bit associated with rNum in the file
fName is set or not. The routine will return TRUE if the bit is set. *)
function CheckBitInBitmap(fName : FnString;
var fId : File; (* var for speed only *)
firstBMRec : PrNumber;
rNum : RecordNumber) : Boolean;
var
page : SinglePage;
prNum : PrNumber;
byteNum : PageRange;
bitNum : BytePosition;
begin
CalculateBitmapBitLocation(firstBMRec,rNum,prNum,byteNum,bitNum);
FetchPage(fName,fId,prNum,page);
if BTreeErrorOccurred then Exit;
CheckBitInBitmap := BitOn(page[byteNum],bitNum);
end; (* end of SetBitInBitmap routine *)
procedure SetBTreeError(errorCode : IOErrorCode);
begin
bTreeErrorCode := errorCode;
end;
function GetBTreeError : IOErrorCode;
begin
GetBTreeError := bTreeErrorCode;
end;
function BTreeErrorOccurred : Boolean;
begin
BTreeErrorOccurred := bTreeErrorCode <> 0;
end;
begin
bTreeErrorCode := NOERROR;
clock.msLongInt := 0;
clock.lsLongInt := 0;
end. (* end of Time unit *)
